home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / osr5 / devtools / dejagnu-971222 / usr / local / share / dejagnu / utils.exp < prev    next >
Encoding:
Text File  |  1998-03-22  |  9.7 KB  |  428 lines
  1. # Copyright (C) 92, 93, 94, 95, 1996, 1997 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # bug-dejagnu@prep.ai.mit.edu
  19.  
  20. # This file was written by Rob Savoye. (rob@cygnus.com)
  21.  
  22. #
  23. # Most of the procedures found here mimic their unix counter-part. 
  24. # This file is sourced by runtest.exp, so they are usable by any test case.
  25. #
  26.  
  27. #
  28. # Gets the directories in a directory
  29. #     args: the first is the dir to look in, the next
  30. #         is the pattern to match. It
  31. #         defaults to *. Patterns are csh style
  32. #         globbing rules
  33. #     returns: a list of dirs or NULL
  34. #
  35. proc getdirs { args } {
  36.     set path [lindex $args 0]
  37.     if { [llength $args] > 1} {
  38.     set pattern [lindex $args 1]
  39.     } else {
  40.     set pattern "*"
  41.     }
  42.     verbose "Looking in ${path} for directories that match \"${pattern}\"" 3
  43.     catch "glob ${path}/${pattern}" tmp
  44.     if { ${tmp} != "" } {
  45.     foreach i ${tmp} {
  46.         if [file isdirectory $i] {
  47.         switch -- "[file tail $i]" {
  48.             "testsuite" -
  49.             "config" -
  50.             "lib" -
  51.             "CVS" -
  52.             "RCS" -
  53.             "SCCS" {
  54.             verbose "Ignoring directory [file tail $i]" 3
  55.             continue
  56.             }
  57.             default {
  58.             if [file readable $i] {
  59.                 verbose "Found directory [file tail $i]" 3
  60.                 lappend dirs $i
  61.             }
  62.             }
  63.         }
  64.         }
  65.     }    
  66.     } else {
  67.     perror "$tmp"
  68.     return ""
  69.     }
  70.     
  71.     if ![info exists dirs] {
  72.     return ""
  73.     } else {
  74.     return $dirs
  75.     }
  76. }
  77.  
  78. #
  79. # Finds all the files recursively
  80. #     rootdir - this is the directory to start the search
  81. #         from. This is and all subdirectories are search for
  82. #         filenames. Directory names are not included in the
  83. #         list, but the filenames have path information. 
  84. #     pattern - this is the pattern to match. Patterns are csh style
  85. #         globbing rules.
  86. #     returns: a list or a NULL.
  87. #
  88. proc find { rootdir pattern } {
  89.     # first find all the directories
  90.     set dirs "$rootdir "
  91.     while 1 {
  92.     set tmp $rootdir
  93.     set rootdir ""
  94.     if [string match "" $tmp] {
  95.         break
  96.     }
  97.     foreach i $tmp {
  98.         set j [getdirs $i]
  99.         if ![string match "" $j] {
  100.         append dirs "$j "
  101.         set rootdir $j
  102.         unset j
  103.         } else {
  104.         set rootdir ""
  105.         }
  106.     }
  107.     set tmp ""
  108.     }
  109.     
  110.     # find all the files that match the pattern
  111.     foreach i $dirs {
  112.     verbose "Looking in $i" 3
  113.     set tmp [glob -nocomplain $i/$pattern]
  114.     if { [llength $tmp] != 0 } {
  115.         foreach j $tmp {
  116.         if ![file isdirectory $j] {
  117.             lappend files $j
  118.             verbose "Adding $j to file list" 3
  119.         }
  120.         }
  121.     }
  122.     }
  123.     
  124.     if ![info exists files] {
  125.     lappend files ""
  126.     }
  127.     return $files
  128. }
  129.  
  130. #
  131. # Search the path for a file. This is basically a version
  132. # of the BSD-unix which utility. This procedure depends on
  133. # the shell environment variable $PATH. It returns 0 if $PATH
  134. # does not exist or the binary is not in the path. If the
  135. # binary is in the path, it returns the full path to the binary.
  136. #
  137. proc which { file } {
  138.     global env
  139.     
  140.     # strip off any extraneous arguments (like flags to the compiler)
  141.     set file [lindex $file 0]
  142.     
  143.     # if it exists then the path must be OK
  144.     # ??? What if $file has no path and "." isn't in $PATH?
  145.     if [file exists $file] {
  146.     return $file
  147.     }
  148.     if [info exists env(PATH)] {
  149.     set path [split $env(PATH) ":"]
  150.     } else {
  151.     return 0
  152.     }
  153.     
  154.     foreach i $path {
  155.     verbose "Checking against $i" 3
  156.     if [file exists $i/$file] {
  157.         if [file executable $i/$file] {
  158.         return $i/$file
  159.         } else {
  160.         warning "$i/$file exists but is not an executable"
  161.         }
  162.     }
  163.     }
  164.     # not in path
  165.     return 0
  166. }
  167.  
  168. #
  169. # Looks for a string in a file. 
  170. #     return:list of lines that matched or NULL if none match.
  171. #     args:  first arg is the filename,
  172. #            second is the pattern,
  173. #            third are any options.
  174. #     Options: line  - puts line numbers of match in list
  175. #
  176. proc grep { args } {
  177.     
  178.     set file [lindex $args 0]
  179.     set pattern [lindex $args 1]
  180.     
  181.     verbose "Grepping $file for the pattern \"$pattern\"" 3
  182.     
  183.     set argc [llength $args]
  184.     if { $argc > 2 } {
  185.     for { set i 2 } { $i < $argc } { incr i } {
  186.         append options [lindex $args $i]
  187.         append options " "
  188.     }
  189.     } else {
  190.     set options ""
  191.     }
  192.     
  193.     set i 0
  194.     set fd [open $file r]
  195.     while { [gets $fd cur_line]>=0 } {
  196.     incr i
  197.     if [regexp -- "$pattern" $cur_line match] {
  198.         if ![string match "" $options] {
  199.         foreach opt $options {
  200.             case $opt in {
  201.             "line" {
  202.                 lappend grep_out [concat $i $match]
  203.             }
  204.             }
  205.         }
  206.         } else {
  207.         lappend grep_out $match
  208.         }
  209.     }
  210.     }
  211.     close $fd
  212.     unset fd
  213.     unset i
  214.     if ![info exists grep_out] {
  215.     set grep_out ""
  216.     }
  217.     return $grep_out
  218. }
  219.  
  220. #
  221. # Remove elements based on patterns. elements are delimited by spaces.
  222. # pattern is the pattern to look for using glob style matching
  223. # list is the list to check against
  224. # returns the new list
  225. #
  226. proc prune { list pattern } {
  227.     foreach i $list {
  228.     verbose "Checking pattern \"$pattern\" against $i" 3
  229.     if ![string match $pattern $i] {
  230.         lappend tmp $i
  231.     } else {
  232.         verbose "Removing element $i from list" 3
  233.     }
  234.     }
  235.     return $tmp
  236. }
  237.  
  238. # 
  239. # Attempt to kill a process that you started on the local machine.
  240. #
  241. proc slay { name } {
  242.     set in [open [concat "|ps"] r]
  243.     while {[gets $in line]>-1} {
  244.     if ![string match "*expect*slay*" $line] {
  245.         if [string match "*$name*" $line] {
  246.         set pid [lindex $line 0]
  247.         catch "exec kill -9 $pid]"
  248.         verbose "Killing $name, pid = $pid\n"
  249.         }
  250.     }
  251.     }
  252.     close $in
  253. }
  254.  
  255. #
  256. # Convert a relative path to an absolute one on the local machine.
  257. #
  258. proc absolute { path } {
  259.     if [string match "." $path] {
  260.         return [pwd]
  261.     }
  262.     
  263.     set basedir [pwd]
  264.     cd $path
  265.     set path [pwd]
  266.     cd $basedir
  267.     return $path
  268. }
  269.  
  270. #
  271. # Source a file and trap any real errors. This ignores extraneous
  272. # output. returns a 1 if there was an error, otherwise it returns 0.
  273. #
  274. proc psource { file } {
  275.     global errorInfo
  276.     global errorCode
  277.  
  278.     unset errorInfo
  279.     if [file exists $file] {
  280.     catch "source $file"
  281.     if [info exists errorInfo] {
  282.         send_error "ERROR: errors in $file\n"
  283.         send_error "$errorInfo"
  284.         return 1
  285.     }
  286.     }
  287.     return 0
  288. }
  289.  
  290. #
  291. # Check if a testcase should be run or not
  292. #
  293. # RUNTESTS is a copy of global `runtests'.
  294. #
  295. # This proc hides the details of global `runtests' from the test scripts, and
  296. # implements uniform handling of "script arguments" where those arguments are
  297. # file names (ie: the "foo" in make check RUNTESTFLAGS="bar.exp=foo").
  298. # "glob" style expressions are supported as well as multiple files (with
  299. # spaces between them).
  300. # Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3*.c bar*.c"
  301. #
  302. proc runtest_file_p { runtests testcase } {
  303.     if [string length [lindex $runtests 1]] {
  304.     set testcase [file tail $testcase]
  305.     foreach ptn [lindex $runtests 1] {
  306.         if [string match $ptn $testcase] {
  307.         return 1
  308.         }
  309.     }
  310.     return 0
  311.     }
  312.     return 1
  313. }
  314.  
  315. #
  316. # Delete various system verbosities from TEXT on SYSTEM
  317. #
  318. # An example is:
  319. # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
  320. #
  321. # SYSTEM is typical $target_triplet or $host_triplet.
  322. #
  323.  
  324. #
  325. # Compares two files line-by-line
  326. #     returns 1 it the files match,
  327. #     returns 0 if there was a file error,
  328. #     returns -1 if they didn't match.
  329. #
  330. proc diff { file_1 file_2 } {
  331.     set eof -1
  332.     set differences 0
  333.     
  334.     if [file exists ${file_1}] {
  335.         set file_a [open ${file_1} r]
  336.     } else {
  337.         warning "${file_1} doesn't exist"
  338.         return 0
  339.     }
  340.     
  341.     if [file exists ${file_2}] {
  342.         set file_b [open ${file_2} r]
  343.     } else {
  344.         warning "${file_2} doesn't exist"
  345.         return 0
  346.     }
  347.     
  348.     verbose "# Diff'ing: ${file_1} ${file_2}\n" 1
  349.     
  350.     set list_a ""
  351.     while { [gets ${file_a} line] != ${eof} } {
  352.         if [regexp "^#.*$" ${line}] {
  353.             continue
  354.         } else {
  355.             lappend list_a ${line}
  356.         }
  357.     }
  358.     close ${file_a}
  359.     
  360.     set list_b ""
  361.     while { [gets ${file_b} line] != ${eof} } {
  362.         if [regexp "^#.*$" ${line}] {
  363.             continue
  364.         } else {
  365.             lappend list_b ${line}
  366.         }
  367.     }
  368.     close ${file_b}
  369.     for { set i 0 } { $i < [llength $list_a] } { incr i } {
  370.         set line_a [lindex ${list_a} ${i}]
  371.         set line_b [lindex ${list_b} ${i}]
  372.  
  373. #        verbose "\t${file_1}: ${i}: ${line_a}\n" 3
  374. #        verbose "\t${file_2}: ${i}: ${line_b}\n" 3
  375.         if [string compare ${line_a} ${line_b}] {
  376.         verbose "line #${i}\n" 2
  377.             verbose "\< ${line_a}\n" 2
  378.             verbose "\> ${line_b}\n" 2
  379.  
  380.         send_log "line #${i}\n"
  381.             send_log "\< ${line_a}\n"
  382.             send_log "\> ${line_b}\n"
  383.  
  384.             set differences -1
  385.         }
  386.     }
  387.     
  388.     if { $differences == -1 || [llength ${list_a}] != [llength ${list_b}] } {
  389.     verbose "Files not the same" 2
  390.         set differences -1
  391.     } else {
  392.     verbose "Files are the same" 2
  393.     set differences 1
  394.     }
  395.     return ${differences}
  396. }
  397.  
  398. #
  399. # Set an environment variable
  400. #
  401. proc setenv { var val } {
  402.     global env
  403.     
  404.     set env($var) $val
  405. }
  406.  
  407. #
  408. # Unset an environment variable
  409. #
  410. proc unsetenv { var } {
  411.     global env
  412.     unset env($var)
  413. }
  414.  
  415. #
  416. # Get a value from an environment variable
  417. #
  418. proc getenv { var } {
  419.     global env
  420.  
  421.     if [info exists env($var)] {
  422.     return $env($var)
  423.     } else {
  424.     return ""
  425.     }
  426. }
  427.  
  428.